home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 2 / Gold Medal Software Volume 2 (Gold Medal) (1994).iso / windows / win31 / fdump102.arj / FILEDUMP.BAS < prev    next >
BASIC Source File  |  1993-10-11  |  7KB  |  161 lines
  1. Option Explicit
  2. '
  3. Global lgGroupItemPointers(50) As Long      'Table of Item Pointers
  4. Global sgGroupItemFileNames(100) As String  'Table of GRP fn's
  5. Global lgItemsCount As Long                 'Count of ItemData Entries
  6. Global igDetailWindowSize(4) As Integer     'Detail Window Size
  7. '
  8. Global sgProgramName As String              'Global Program Name
  9. Global igFromForm As Integer                'Commercial From Switch
  10. Global sgRegistrationStatus As String       'Registration Status
  11. Global sgProgramVersion As String           'Version Number
  12. Global sgCompuserveID As String             'Compuserve ID
  13. '
  14. Global sgGroupsDrive As String              'Groups Drive
  15. Global sgGroupsPath As String               'Groups Path
  16. '
  17. Global fgBaseFormTop As Single              'Base Scale Top
  18. Global fgBaseFormHeight As Single           'Base Scale Height
  19. Global fgBaseFormLeft As Single             'Base Scale Left
  20. Global fgBaseFormWidth As Single            'Base Scale Width
  21. '
  22. Global fgCurrentFormTop As Single           'Current Scale Top
  23. Global fgCurrentFormHeight As Single        'Current Scale Height
  24. Global fgCurrentFormLeft As Single          'Current Scale Left
  25. Global fgCurrentFormWidth As Single         'Current Scale Width
  26. '
  27. Global fgCurrentHeightFactor As Single      'Heigth Adjustment Ratio
  28. Global fgCurrentWidthFactor As Single       'Width Adjustment Ratio
  29. '
  30. Global igErrorNumber As Integer             'Error Number
  31. Global sgErrorMessage As String             'Error Message
  32. '
  33. Global sgWindowsDirectory As String         'Windows Directory
  34. '
  35. Global igLongestDetailLine As Integer       'GrpFiles Longest Line
  36. Global sgWorkFileName As String             'Work File DOS Filename
  37. '
  38. '---------------------------------------------------------
  39. '
  40. ' Get the Windows Directory Value
  41. Declare Function GetWindowsDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
  42. '' Functions for List Box Horizontal Scrolling
  43. '
  44. Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As Long) As Long
  45. ' Get the handle for a Window
  46. Declare Function GetFocus Lib "User" () As Integer
  47. ' Write a Private Profile Entry
  48. Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lplFileName As String) As Integer
  49. ' Read a Private Profile Entry
  50. Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpAppName As String, ByVal lpKeyName As Any, ByVal lpString As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lplFileName As String) As Integer
  51. '
  52.  
  53. '------------------------------------------------------
  54. ' Calls the Windows API to get a Private Profile entry
  55. '------------------------------------------------------
  56. Sub GetPProfileString (sSection As String, sEntry As String, sDefault As String, sFilename As String, sReturnBuffer As String, iReturnBuffer As Integer)
  57.   '
  58.   Dim iReturn As Integer
  59.   Dim sTemp As String
  60.   Dim sDialogTitle As String
  61.   '
  62.   sDialogTitle = "GetPProfileString"
  63.   '
  64.   iReturn = GetPrivateProfileString(sSection, sEntry, sDefault, sReturnBuffer, iReturnBuffer, sFilename)
  65.   '
  66.   If iReturn = 0 Or Left$(sReturnBuffer, 5) = "ERROR" Then
  67.     sTemp = "           WARNING           " & Chr$(13) & Chr$(10)
  68.     sTemp = sTemp & "** Error reading .INI File **" & Chr$(13) & Chr$(10)
  69.     ' Extra spaces on following lines compensate for proportional font
  70.     sTemp = sTemp & "Section     : " & sSection & Chr$(13) & Chr$(10)
  71.     sTemp = sTemp & "Entry        : " & sEntry & Chr$(13) & Chr$(10)
  72.     sTemp = sTemp & "Filename  : " & sFilename & Chr$(13) & Chr$(10)
  73.     sTemp = sTemp & Chr$(13) & Chr$(10) & "A new .INI will be created when you use File/Exit" & Chr$(13) & Chr$(10)
  74.     MsgBox sTemp, MB_ICONEXCLAMATION, sDialogTitle
  75.     sReturnBuffer = "ERROR"
  76.   End If
  77.  
  78. End Sub
  79.  
  80. '------------------------------------------------------
  81. ' Convert 2 adjacent bytes of a String to a single Long Integer
  82. '------------------------------------------------------
  83. Function lgBytesToLong (sSource As String, ByVal iPosition As Integer) As Long
  84.   '
  85.   Dim lWork1 As Long
  86.   '
  87.   lWork1 = Val("&H" & Hex(Asc(Mid$(sSource, iPosition + 1, 1)))) * 256
  88.   lWork1 = lWork1 + Val("&H" & Hex(Asc(Mid$(sSource, iPosition, 1))))
  89.   lgBytesToLong = lWork1
  90.  
  91. End Function
  92.  
  93. '--------------------------------------------------
  94. ' Calls the windows API to get the windows directory
  95. '--------------------------------------------------
  96. Function sGetWindowsDir () As String
  97.   '
  98.   Dim sWork As String
  99.   Dim iGWD As Integer
  100.   '
  101.   sWork = String$(145, 0)                  ' Set Buffer size
  102.   iGWD = GetWindowsDirectory(sWork, 145)  ' Make API Call
  103.   sWork = Left$(sWork, iGWD)             ' Trim Buffer
  104.   '
  105.   If Right$(sWork, 1) <> "\" Then          ' Add \ if necessary
  106.     sGetWindowsDir = sWork + "\"
  107.   Else
  108.     sGetWindowsDir = sWork
  109.   End If
  110.   
  111. End Function
  112.  
  113. '---------------------------------------------------------
  114. ' Formats an AsciiZ String with a Max. char. limit
  115. '---------------------------------------------------------
  116. Sub sub_gAsciiZ (sSource As String, sTarget As String, iLimit As Integer)
  117.   '
  118.   'Sample Call:
  119.   '  Call sub_gAsciiZ(sWork2, sWork3, 30)
  120.   '
  121.   Dim sWork1 As String
  122.   Dim iWork1 As Integer
  123.   '
  124.   sWork1 = Mid$(sSource, 1, 1)
  125.   iWork1 = 1
  126.   sTarget = ""
  127.   Do Until Asc(sWork1) = 0
  128.     If iWork1 > iLimit Then Exit Do
  129.     sTarget = sTarget + sWork1
  130.     iWork1 = iWork1 + 1
  131.     sWork1 = Mid$(sSource, iWork1, 1)
  132.     Loop
  133.  
  134. End Sub
  135.  
  136. '------------------------------------------------------
  137. ' Calls the Windows API to put a Private Profile entry
  138. '------------------------------------------------------
  139. Sub WritePProfileString (sSection As String, sEntry As String, sString As String, sFilename As String)
  140.   '
  141.   Dim iResult As Integer
  142.   Dim sDialogTitle As String
  143.   Dim sTemp As String
  144.   '
  145.   sDialogTitle = "WritePProfileString"
  146.   '
  147.   iResult = WritePrivateProfileString(sSection, sEntry, sString, sFilename)
  148.   '
  149.   If iResult = 0 Then
  150.     sTemp = "** Error updating INI File **" & Chr$(10)
  151.     ' Extra spaces on following lines compensate for proportional font
  152.     sTemp = sTemp & "sSection     : " & sSection & Chr$(10)
  153.     sTemp = sTemp & "sEntry         : " & sEntry & Chr$(10)
  154.     sTemp = sTemp & "sString        : " & sString & Chr$(10)
  155.     sTemp = sTemp & "sFilename  : " & sFilename & Chr$(10)
  156.     MsgBox sTemp, MB_ICONSTOP, sDialogTitle
  157.   End If
  158.  
  159. End Sub
  160.  
  161.